(*
 * Copyright (C) 2006-2009 Citrix Systems Inc.
 *
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU Lesser General Public License as published
 * by the Free Software Foundation; version 2.1 only. with the special
 * exception on linking described in file LICENSE.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU Lesser General Public License for more details.
 *)
open Printf
open Datamodel_types
open Datamodel
open Datamodel_utils
open Dm_api
open Xapi_stdext_pervasives.Pervasiveext

(*column widths for the autogenerated tables*)
let col_width_15 = 15

let col_width_20 = 20

let col_width_30 = 30

let col_width_40 = 40

let col_width_70 = 70

let pad_right x max_width =
  let length = String.length x in
  if String.length x < max_width then
    x ^ String.make (max_width - length) ' '
  else
    x

let compare_case_ins x y =
  compare (String.lowercase_ascii x) (String.lowercase_ascii y)

let escape s =
  let open Xapi_stdext_std.Xstringext in
  let sl = String.explode s in
  let esc_char = function
    | '\\' ->
        "&#92;"
    | '*' ->
        "&#42;"
    | '_' ->
        "&#95;"
    | '{' ->
        "&#123;"
    | '}' ->
        "&#125;"
    | '[' ->
        "&#91;"
    | ']' ->
        "&#93;"
    | '(' ->
        "&#40;"
    | ')' ->
        "&#41;"
    | '>' ->
        "&gt;"
    | '<' ->
        "&lt;"
    | '#' ->
        "&#35;"
    | '+' ->
        "&#43;"
    | '-' ->
        "&#45;"
    | '!' ->
        "&#33;"
    | c ->
        String.make 1 c
  in
  let escaped_list = List.map esc_char sl in
  String.concat "" escaped_list

let is_prim_type = function
  | String | Int | Float | Bool | DateTime ->
      true
  | _ ->
      false

let is_prim_opt_type = function None -> true | Some (ty, _) -> is_prim_type ty

let rec of_ty_verbatim = function
  | SecretString | String ->
      "string"
  | Int ->
      "int"
  | Float ->
      "float"
  | Bool ->
      "bool"
  | DateTime ->
      "datetime"
  | Enum (name, things) ->
      name
  | Set x ->
      sprintf "%s set" (of_ty_verbatim x)
  | Map (a, b) ->
      sprintf "(%s -> %s) map" (of_ty_verbatim a) (of_ty_verbatim b)
  | Ref obj ->
      obj ^ " ref"
  | Record obj ->
      obj ^ " record"
  | Option x ->
      sprintf "%s option" (of_ty_verbatim x)

let rec of_ty = function
  | String ->
      "string"
  | Int ->
      "int"
  | Float ->
      "float"
  | Bool ->
      "bool"
  | DateTime ->
      "datetime"
  | Enum (name, things) ->
      escape name
  | Set x ->
      of_ty x ^ " set"
  | Map (a, b) ->
      "(" ^ of_ty a ^ " &#45;&gt; " ^ of_ty b ^ ") map"
  | Ref obj ->
      escape obj ^ " ref"
  | Record obj ->
      escape obj ^ " record"
  | _ ->
      assert false

let of_ty_opt = function None -> "void" | Some (ty, _) -> of_ty ty

let of_ty_opt_verbatim = function
  | None ->
      "void"
  | Some (ty, _) ->
      of_ty_verbatim ty

let desc_of_ty_opt = function None -> "" | Some (_, desc) -> desc

let string_of_qualifier = function
  | StaticRO ->
      "_RO/constructor_"
  | DynamicRO ->
      "_RO/runtime_"
  | RW ->
      "_RW_"

let is_removal_marker x = match x with Removed, _, _ -> true | _ -> false

let is_deprecation_marker x =
  match x with Deprecated, _, _ -> true | _ -> false

(* Make a markdown section for an API-specified message *)
let markdown_section_of_message printer obj ~is_class_deprecated
    ~is_class_removed x =
  let is_event_from =
    String.lowercase_ascii obj.name = "event"
    && String.lowercase_ascii x.msg_name = "from"
  in
  let return_type = of_ty_opt_verbatim x.msg_result in
  printer (sprintf "#### RPC name: %s" (escape x.msg_name)) ;
  printer "" ;
  if List.exists is_removal_marker x.msg_lifecycle || is_class_removed then (
    printer "**This message is removed.**" ;
    printer ""
  ) else if
      List.exists is_deprecation_marker x.msg_lifecycle || is_class_deprecated
    then (
    printer "**This message is deprecated.**" ;
    printer ""
  ) ;
  printer "_Overview:_" ;
  printer "" ;
  printer (escape x.msg_doc) ;
  printer "" ;
  printer "_Signature:_" ;
  printer "" ;
  printer "```" ;
  let result =
    if is_event_from then
      "<event batch>"
    else
      of_ty_opt_verbatim x.msg_result
  in
  printer
    (sprintf "%s %s (%s)" result x.msg_name
       (String.concat ", "
          ((if x.msg_session then ["session ref session_id"] else [])
          @ List.map
              (fun p -> of_ty_verbatim p.param_type ^ " " ^ p.param_name)
              x.msg_params
          ))) ;
  printer "```" ;
  printer "" ;
  if x.msg_params <> [] then (
    printer "_Arguments:_" ;
    printer "" ;
    printer
      "|type                          |name                          \
       |description                             |" ;
    printer
      "|:-----------------------------|:-----------------------------|:---------------------------------------|" ;
    if x.msg_session then
      printer
        "|session ref                   |session_id                    \
         |Reference to a valid session            |" ;
    let get_param_row p =
      sprintf "|`%s`|%s|%s|"
        (pad_right (of_ty_verbatim p.param_type) (col_width_30 - 2))
        (pad_right (escape p.param_name) col_width_30)
        (pad_right (escape p.param_doc) col_width_40)
    in
    List.iter (fun p -> printer (get_param_row p)) x.msg_params ;
    printer ""
  ) ;
  let print_rbac y =
    match y.msg_allowed_roles with
    | Some yy when yy <> [] ->
        printer ("_Minimum Role:_ " ^ List.hd (List.rev yy)) ;
        printer ""
    | _ ->
        ()
  in
  print_rbac x ;
  printer
    ("_Return Type:_"
    ^ if is_event_from then " an event batch" else sprintf " `%s`" return_type
    ) ;
  printer "" ;
  let descr = desc_of_ty_opt x.msg_result in
  if descr <> "" then (
    printer (escape descr) ;
    printer ""
  ) ;
  if x.msg_errors <> [] then (
    let error_codes =
      List.map (fun err -> sprintf "`%s`" err.err_name) x.msg_errors
    in
    printer
      (sprintf "_Possible Error Codes:_ %s" (String.concat ", " error_codes)) ;
    printer ""
  )

let print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x =
  printer (sprintf "### Fields for class: " ^ escape x.name) ;
  printer "" ;
  if x.contents = [] then
    printer ("Class " ^ escape x.name ^ " has no fields.")
  else (
    printer
      "|Field               |Type                |Qualifier      \
       |Description                             |" ;
    printer
      "|:-------------------|:-------------------|:--------------|:---------------------------------------|" ;
    let print_field_content printer
        ({release; qualifier; ty; field_description= description} as y) =
      let wired_name = Datamodel_utils.wire_name_of_field y in
      let descr =
        ( if List.exists is_removal_marker y.lifecycle || is_class_removed then
            "**Removed**. "
        else if
        List.exists is_deprecation_marker y.lifecycle || is_class_deprecated
      then
          "**Deprecated**. "
        else
          ""
        )
        ^ escape description
      in
      printer
        (sprintf "|%s|`%s`|%s|%s|"
           (pad_right (escape wired_name) col_width_20)
           (pad_right (of_ty_verbatim ty) (col_width_20 - 2))
           (pad_right (string_of_qualifier qualifier) col_width_15)
           (pad_right descr col_width_40))
    in
    x
    |> Datamodel_utils.fields_of_obj
    |> List.sort (fun x y ->
           compare_case_ins
             (Datamodel_utils.wire_name_of_field x)
             (Datamodel_utils.wire_name_of_field y))
    |> List.iter (print_field_content printer) ;
    if String.lowercase_ascii x.name = "event" then
      printer
        (sprintf "|%s|`%s`|%s|%s|"
           (pad_right "snapshot" col_width_20)
           (pad_right "<object record>" (col_width_20 - 2))
           (pad_right "_RO/runtime_" col_width_15)
           (pad_right
              "The record of the database object that was added, changed or \
               deleted"
              col_width_40))
  )

let of_obj printer x =
  printer (sprintf "## Class: %s" (escape x.name)) ;
  printer "" ;
  let is_class_removed = List.exists is_removal_marker x.obj_lifecycle in
  let is_class_deprecated = List.exists is_deprecation_marker x.obj_lifecycle in
  if is_class_removed then (
    printer "**This class is removed.**" ;
    printer ""
  ) else if is_class_deprecated then (
    printer "**This class is deprecated.**" ;
    printer ""
  ) ;
  printer (escape x.description) ;
  printer "" ;
  print_field_table_of_obj printer ~is_class_deprecated ~is_class_removed x ;
  printer "" ;
  printer (sprintf "### RPCs associated with class: " ^ escape x.name) ;
  printer "" ;
  if x.messages = [] then (
    printer
      (sprintf "Class %s has no additional RPCs associated with it."
         (escape x.name)) ;
    printer ""
  ) else
    x.messages
    |> List.sort (fun x y -> compare_case_ins x.msg_name y.msg_name)
    |> List.iter
         (markdown_section_of_message printer x ~is_class_deprecated
            ~is_class_removed)

let print_enum printer = function
  | Enum (name, options) ->
      printer
        (sprintf "|`enum %s`|                                        |"
           (pad_right name (col_width_40 - 7))) ;
      printer
        "|:---------------------------------------|:---------------------------------------|" ;
      let print_option (opt, description) =
        printer
          (sprintf "|`%s`|%s|"
             (pad_right opt (col_width_40 - 2))
             (pad_right (escape description) col_width_40))
      in
      options
      |> List.sort (fun (x, _) (y, _) -> compare_case_ins x y)
      |> List.iter print_option ;
      printer ""
  | _ ->
      ()

let error_doc printer {err_name= name; err_params= params; err_doc= doc} =
  printer (sprintf "### %s" (escape name)) ;
  printer "" ;
  printer (escape doc) ;
  printer "" ;
  if params = [] then
    printer "No parameters."
  else (
    printer "_Signature:_" ;
    printer "" ;
    printer "```" ;
    printer (sprintf "%s(%s)" name (String.concat ", " params)) ;
    printer "```"
  ) ;
  printer ""

let print_classes api io =
  let printer text = fprintf io "%s\n" text in
  (* Remove private messages that are only used internally (e.g. get_record_internal) *)
  let api =
    Dm_api.filter
      (fun _ -> true)
      (fun _ -> true)
      (fun msg ->
        match msg.msg_tag with FromObject (Private _) -> false | _ -> true)
      api
  in
  let system =
    objects_of_api api |> List.sort (fun x y -> compare_case_ins x.name y.name)
  in
  let relations = relations_of_api api in
  printer
    "# API Reference - Types and Classes\n\n\
     ## Classes\n\n\
     The following classes are defined:\n\n\
     |Name                \
     |Description                                                           |\n\
     |:-------------------|:---------------------------------------------------------------------|" ;
  let get_descr obj =
    ( if List.exists is_removal_marker obj.obj_lifecycle then
        "**Removed**. "
    else if List.exists is_deprecation_marker obj.obj_lifecycle then
      "**Deprecated**. "
    else
      ""
    )
    ^ escape obj.description
  in
  List.iter
    (fun obj ->
      printer
        (sprintf "|`%s`|%s|"
           (pad_right obj.name (col_width_20 - 2))
           (pad_right (get_descr obj) col_width_70)))
    system ;
  printer
    "\n\
     ## Relationships Between Classes\n\n\
     Fields that are bound together are shown in the following table:\n\n\
     |_object.field_                          \
     |_object.field_                          |_relationship_ |\n\
     |:---------------------------------------|:---------------------------------------|:--------------|" ;
  List.iter
    (function
      | ((a, a_field), (b, b_field)) as rel ->
          let c = Relations.classify api rel in
          let afield = a ^ "." ^ a_field in
          let bfield = b ^ "." ^ b_field in
          printer
            (sprintf "|`%s`|`%s`|%s|"
               (pad_right afield (col_width_40 - 2))
               (pad_right bfield (col_width_40 - 2))
               (pad_right (Relations.string_of_classification c) col_width_15)))
    relations ;
  printer
    "\n\
     The following figure represents bound fields (as specified above) \
     diagramatically, using crow's foot notation to specify one-to-one, \
     one-to-many or many-to-many relationships:\n\n\
     ![Class relationships](classes.png 'Class relationships')\n\n\
     ## Types\n\n\
     ### Primitives\n\n\
     The following primitive types are used to specify methods and fields in \
     the API Reference:\n\n\
     |Type    |Description                                 |\n\
     |:-------|:-------------------------------------------|\n\
     |string  |text strings                                |\n\
     |int     |64-bit integers                             |\n\
     |float   |IEEE double-precision floating-point numbers|\n\
     |bool    |boolean                                     |\n\
     |datetime|date and timestamp                          |\n\n\
     ### Higher-order types\n\n\
     The following type constructors are used:\n\n\
     |Type              \
     |Description                                             |\n\
     |:-----------------|:-------------------------------------------------------|\n\
     |_c_ ref           |reference to an object of class \
     _c_                     |\n\
     |_t_ set           |a set of elements of type \
     _t_                           |\n\
     |(_a &#45;&gt; b_) map     |a table mapping values of type _a_ to values \
     of type _b_|\n\n\
     ### Enumeration types\n\n\
     The following enumeration types are used:\n" ;
  let type_comparer x y =
    match (x, y) with
    | Enum (a, _), Enum (b, _) ->
        compare_case_ins a b
    | _ ->
        compare x y
  in
  Types.of_objects system
  |> List.sort type_comparer
  |> List.iter (print_enum printer) ;
  List.iter (fun x -> of_obj printer x) system

let print_errors io =
  let printer text = fprintf io "%s\n" text in
  printer
    "# API Reference - Error Handling\n\n\
     When a low-level transport error occurs, or a request is malformed at the \
     HTTP\n\
     or RPC level, the server may send an HTTP 500 error response, or the client\n\
     may simulate the same. The client must be prepared to handle these errors,\n\
     though they may be treated as fatal.\n\n\
     On the wire, these are transmitted in a form similar to this when using the\n\
     XML-RPC protocol:\n\n\
     ```\n\
     $curl -D - -X POST https://server -H 'Content-Type: application/xml' \\\n\
     > -d '<?xml version=\"1.0\"?>\n\
     > <methodCall>\n\
     >   <methodName>session.logout</methodName>\n\
     > </methodCall>'\n\
     HTTP/1.1 500 Internal Error\n\
     content-length: 297\n\
     content-type:text/html\n\
     connection:close\n\
     cache-control:no-cache, no-store\n\n\
     <html><body><h1>HTTP 500 internal server error</h1>An unexpected error \
     occurred;\n\
    \ please wait a while and try again. If the problem persists, please \
     contact your\n\
    \ support representative.<h1> Additional information \
     </h1>Xmlrpc.Parse_error(&quo\n\
     t;close_tag&quot;, &quot;open_tag&quot;, _)</body></html>\n\
     ```\n\n\
     When using the JSON-RPC protocol:\n\n\
     ```\n\
     $curl -D - -X POST https://server/jsonrpc -H 'Content-Type: \
     application/json' \\\n\
     > -d '{\n\
     >     \"jsonrpc\": \"2.0\",\n\
     >     \"method\": \"session.login_with_password\",\n\
     >     \"id\": 0\n\
     > }'\n\
     HTTP/1.1 500 Internal Error\n\
     content-length: 308\n\
     content-type:text/html\n\
     connection:close\n\
     cache-control:no-cache, no-store\n\n\
     <html><body><h1>HTTP 500 internal server error</h1>An unexpected error \
     occurred;\n\
    \ please wait a while and try again. If the problem persists, please \
     contact your\n\
    \ support representative.<h1> Additional information \
     </h1>Jsonrpc.Malformed_metho\n\
     d_request(&quot;{jsonrpc=...,method=...,id=...}&quot;)</body></html>\n\
     ```\n\n\
     All other failures are reported with a more structured error response, to\n\
     allow better automatic response to failures, proper internationalisation of\n\
     any error message, and easier debugging.\n\n\
     On the wire, these are transmitted like this when using the XML-RPC \
     protocol:\n\n\
     ```xml\n\
    \    <struct>\n\
    \      <member>\n\
    \        <name>Status</name>\n\
    \        <value>Failure</value>\n\
    \      </member>\n\
    \      <member>\n\
    \        <name>ErrorDescription</name>\n\
    \        <value>\n\
    \          <array>\n\
    \            <data>\n\
    \              <value>MAP_DUPLICATE_KEY</value>\n\
    \              <value>Customer</value>\n\
    \              <value>eSpiel Inc.</value>\n\
    \              <value>eSpiel Incorporated</value>\n\
    \            </data>\n\
    \          </array>\n\
    \        </value>\n\
    \      </member>\n\
    \    </struct>\n\
     ```\n\n\
     Note that `ErrorDescription` value is an array of string values. The\n\
     first element of the array is an error code; the remainder of the array are\n\
     strings representing error parameters relating to that code.  In this case,\n\
     the client has attempted to add the mapping _Customer &#45;&gt;\n\
     eSpiel Incorporated_ to a Map, but it already contains the mapping\n\
     _Customer &#45;&gt; eSpiel Inc._, and so the request has failed.\n\n\
     When using the JSON-RPC protocol v2.0, the above error is transmitted as:\n\n\
     ```json\n\
     {\n\
    \    \"jsonrpc\": \"2.0\",\n\
    \    \"error\": {\n\
    \        \"code\": 1,\n\
    \        \"message\": \"MAP_DUPLICATE_KEY\",\n\
    \        \"data\": [\n\
    \            \"Customer\",\"eSpiel Inc.\",\"eSpiel Incorporated\"\n\
    \        ]\n\
    \    },\n\
    \    \"id\": 3\n\
    \  }\n\
     ```\n\n\
     Finally, when using the JSON-RPC protocol v1.0:\n\n\
     ```json\n\
     {\n\
    \  \"result\": null,\n\
    \  \"error\": [\n\
    \      \"MAP_DUPLICATE_KEY\",\"Customer\",\"eSpiel Inc.\",\"eSpiel \
     Incorporated\"\n\
    \  ],\n\
    \  \"id\": \"xyz\"\n\
     }\n\
     ```\n\n\
     Each possible error code is documented in the following section.\n\n\
     ## Error Codes\n" ;
  (* Sort the errors alphabetically, then generate one section per code. *)
  let errs =
    Hashtbl.fold (fun name err acc -> (name, err) :: acc) Datamodel.errors []
  in
  List.iter (error_doc printer)
    (snd (List.split (List.sort (fun (n1, _) (n2, _) -> compare n1 n2) errs)))

let all api destdir =
  Xapi_stdext_unix.Unixext.mkdir_rec destdir 0o755 ;
  let with_file filename f =
    let io = open_out (Filename.concat destdir filename) in
    finally (fun () -> f io) (fun () -> close_out io)
  in
  with_file "api-ref-autogen.md" (print_classes api) ;
  with_file "api-ref-autogen-errors.md" print_errors
